Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/ftpser1a/ftp_srv.bas

BASIC Source File | 1999-10-04 | 13.0 KB | 453 lines

Attribute VB_Name = "FTP_SRV1"

Global sintax_error_list(10) As String 'the list of the messagges which signal a sintax error in a FTP command


Type user
  'indexes user name and password inside
  '<usernames_list> and <passwords_list> arrays
  list_index As Integer
  control_slot As Long 'slot number used by client to send commands to server. On this slot also travel the replies of server.
  data_slot As Long    'slot number used by server to send data to client
  IP_address As String 'client IP address
  Port As Integer      'number of client data port
  'representation type to use for data
  'encoding (ex. ASCII o EBCDIC), default type is A (= ASCII)
  data_representation As String * 1
  'type of vertical format control
  '(ie. line-feed, form-feed), default
  'value is N (No print = no command)
  data_format_ctrls As String * 1
  'file structure (ex. File-structure, Record-structure),
  'default value is F (File-structure = no internal
  'structure)
  data_structure As String * 1
  'indicates if the data are processing before
  'transmission (ex. Stream-mode, Block-mode),
  'default value is S (Stream-mode = no
  'processing)
  data_tx_mode As String * 1
  'current working directory
  cur_dir As String
  'user state:
  'in state 0 the user sends access control commands;
  'in state 1 the user sends transfer parameter commands;
  'in state 2 the user sends FTP service commands.
  state As Integer
  full As Integer  'if true the record is already in use
  temp_data As String  'contains temporary data
End Type
Global users(MAX_N_USERS) As user

Type file_info
  Full_Name As String
  data_representation As String * 1
  open_file As Integer
  retr_stor As Integer  '0=RETR; 1=STOR
  Buffer As String  'contains data to send
  File_Len As Long  '--- Binary mode only
  blocks As Long  'number of 1024 bytes blocks in file
  spare_bytes As Long
  next_block As Long  'next block to send
  next_byte As Long  'points to position in file of the next block to send
  try_again As Integer  'if try_again=true the old line is sent =Ascii mode only
End Type
Global files_info(5) As file_info

'contains error during function call
Global retf As Integer

'*** Variables used during TCP/IP exchange
'slot number assigned to Server
Global ServerSlot As Long
'number of clients connected to server
Global num_users As Integer
Global ListenSock As Long
Global NewSlot As Long

Function args_ctrl(ArgS As String, Type_Args As String, ByRef Argument() As String) As Integer
Dim Dummy As String
Dim len_args As Integer, i As Integer, ascii As Integer
Dim s As Integer, e As Integer
ReDim h(6) As Long

'the arguments of type <username>, <password> and
'<pathname> are strings
If Type_Args = "username" Or Type_Args = "password" _
Or Type_Args = "pathname" Then
  Type_Args = "string"
End If

'command Ok
args_ctrl = 0

len_args = Len(ArgS)

Select Case Type_Args

  Case "string": '<string>  <string:= char | char&string>
    For i = 1 To len_args
      ascii = Asc(Mid$(ArgS, i, 1))
      If ascii < 32 Or ascii > 126 Then      'only printable characters
        args_ctrl = 3           'sintax error in parameters or arguments
        Exit For
      End If
    Next
    Argument(0) = ArgS

  Case "host-port": '<h1,h2,h3,h4,p1,p2>  <h?:=1..255>  <p?:=1..255>
    '<Host> is formed by 4 elements, divided by comma, which representing IP address;
    '<port> is formed by 2 elements, divided by comma, which representing the MSB and LSB of the port.
    'add a separator for simplifing the procedure
    Dummy = ArgS & ","
    Debug.Print "Port String = " & Dummy
    e = 1    'point to next element
    For i = 1 To 6
      s = InStr(e, Dummy, ",") 's point to next separator (ie. comma)
      If s = 0 Then
        args_ctrl = 3          'sintax error in parameters or arguments
        Exit For
      Else
        'every element of the argument must be an integer,
        'represented as string, in the range 1 to 255
        h(i) = Val(Mid$(Dummy, e, s - e))
        Debug.Print "h(" & CStr(i) & ") = " & h(i)
        If h(i) < 0 Or h(i) > 255 Then
          args_ctrl = 3       'sintax error in parameters or arguments
          Exit For
        End If
      End If
      e = s + 1       'point to next element
    Next
    Argument(0) = Format$(h(1))              'IP address
    Argument(1) = Format$(h(2))
    Argument(2) = Format$(h(3))
    Argument(3) = Format$(h(4))
    Argument(4) = Format$(h(5) * 256 + h(6)) 'port

  Case "type-code":  '<A [A N] | I>
  S1 = InStr(ArgS, " ")
  If S1 = 0 Then
    If ArgS = "A" Or ArgS = "" Then
      'arguments assume default values
      Argument(0) = "A"  'Ascii
      Argument(1) = "N"  'No print
    ElseIf ArgS = "E" Then
      'command not implemented for that parameter
      args_ctrl = 6
      Argument(0) = ArgS
    ElseIf ArgS = "I" Then
      Argument(0) = "I"
    Else
      'sintax error in parameters or arguments
      args_ctrl = 3
      Argument(0) = ArgS
    End If
  Else
    If Left$(ArgS, S1 - 1) = "A" Then
      Argument(0) = "A"
      While Mid$(ArgS, S1, 1) = " "
        S1 = S1 + 1
      Wend
      If Mid$(ArgS, S1) = "" Or Mid$(ArgS, S1) = "N" Then
        Argument(1) = "N"
      ElseIf Mid$(ArgS, S1) = "T" Then
        'command not implemented for that parameter
        args_ctrl = 6
        Argument(1) = Mid$(ArgS, S1)
      ElseIf Mid$(ArgS, S1) = "C" Then
        'command not implemented for that parameter
        args_ctrl = 6
        Argument(1) = Mid$(ArgS, S1)
      Else
        'sintax error in parameters or arguments
        args_ctrl = 3
        Argument(1) = Mid$(ArgS, S1)
      End If
    ElseIf Left$(ArgS, S1 - 1) = "L" Then
      'command not implemented for that parameter
      args_ctrl = 6
      Argument(1) = Mid$(ArgS, S1)
    ElseIf Left$(ArgS, S1 - 1) = "I" Then
      Argument(0) = "I"
    Else
      'sintax error in parameters or arguments
      args_ctrl = 3
      Argument(0) = Left$(ArgS, S1 - 1)
    End If
  End If

  Case "mode-code":  '<S>
  If ArgS = "" Or ArgS = "S" Then
    'argument assumes default value
    Argument(0) = "S"  'Stream
  ElseIf ArgS = "B" Then
    'command not implemented for that parameter
    args_ctrl = 6
    Argument(0) = ArgS
  ElseIf ArgS = "C" Then
    'command not implemented for that parameter
    args_ctrl = 6
    Argument(0) = ArgS
  Else
    'sintax error in parameters or arguments
    args_ctrl = 3
    Argument(0) = Left$(ArgS, S1 - 1)
  End If

  Case "structure-code":  '<F | R>
  If ArgS = "" Or ArgS = "F" Then
    'argument assumes default value
    Argument(0) = "F" 'File
  ElseIf ArgS = "R" Then
    'command not implemented for that parameter
    args_ctrl = 6
    Argument(0) = ArgS
  ElseIf ArgS = "P" Then
    'command not implemented for that parameter
    args_ctrl = 6
    Argument(0) = ArgS
  Else
    'sintax error in parameters or arguments
    args_ctrl = 3
    Argument(0) = ArgS
  End If

End Select

End Function

Function close_data_connect(Id_User As Integer) As Integer

  retf = closesocket(users(Id_User).data_slot)
  If retf = 0 Then
    'updates user record
    users(Id_User).data_slot = INVALID_SOCKET
    users(Id_User).IP_address = ""
    users(Id_User).Port = 0
    users(Id_User).state = 2
  End If
  close_data_connect = retf

End Function

Function logoff(Id_User As Integer) As Integer

  retf = send_reply("221 Closing control connection, GoodBye!", Id_User)
  retf = closesocket(users(Id_User).control_slot)
  If retf = 0 Then
    're-initialize the record containing user informations
    users(Id_User).list_index = 0
    users(Id_User).control_slot = INVALID_SOCKET
    users(Id_User).data_slot = INVALID_SOCKET
    users(Id_User).IP_address = ""
    users(Id_User).Port = 0
    users(Id_User).data_representation = "A"
    users(Id_User).data_format_ctrls = "N"
    users(Id_User).data_structure = "F"
    users(Id_User).data_tx_mode = "S"
    users(Id_User).cur_dir = ""
    users(Id_User).state = 0
    users(Id_User).full = False
  Else
    FtpServ.StatusBar.Panels(1) = "Error: Couldn't Close Connection!"
  End If
  num_users = num_users - 1
  FtpServ.UsrCnt = CStr(num_users)
  logoff = retf

End Function

Function open_data_connect(Id_User As Integer) As Integer

  'open data connection
  retf = send_reply("150 Open data connection.", Id_User)
  open_data_connect = retf

End Function

Function receive_data(RecvBuffer As String, Id_User As Integer) As Integer
Dim fixstr As String * 1024

  'receives data on connection
  retf = recv(users(Id_User).data_slot, fixstr, 1024, 0)
  If retf > 0 Then
    RecvBuffer = Left$(fixstr, retf)
  End If
  receive_data = retf

End Function

Function send_data(data_ As String, Id_User As Integer) As Integer
'write buffer
Dim WriteBuffer As String
'write buffer lenght
Dim lenBuffer As Integer

  'sends data on connection
  WriteBuffer = data_
  lenBuffer = Len(WriteBuffer)
  retf = send(users(Id_User).data_slot, WriteBuffer, lenBuffer, 0)
  send_data = retf

End Function

Function send_reply(reply As String, Id_User As Integer) As Integer
Dim WriteBuffer As String
Dim lenBuffer As Integer 'buffer lenght

  'sends reply to user <id_user>
  WriteBuffer = reply & vbCrLf
  lenBuffer = Len(WriteBuffer)
  retf = send(users(Id_User).control_slot, WriteBuffer, lenBuffer, 0)
  If retf = SOCKET_ERROR Then
    ServerLog "Error sending reply:" & CStr(retf)
  Else
    'log replies
    ServerLog "<" & Format$(Id_User, "000") & "> " & Format$(Date$, "dd/mm/yy ") & Format$(Time$, "hh:mm - ") & reply
  End If
  send_reply = retf

End Function

Function sintax_ctrl(cmd As String, ByRef Kwrd As String, ByRef Argument() As String) As Integer
Dim ArgS As String
Dim k As Integer

'the command must be terminated by CR&LF characters
len_cmd = InStr(cmd, vbCrLf) - 1
If len_cmd = 0 Then
  sintax_ctrl = 2 'sintax error, command unrecognized
  Exit Function
Else
  'suppresses CR&LF characters
  cmd = Left$(cmd, len_cmd)
End If

'extract keyword
k = InStr(cmd, " ")
If k <> 0 Then
  'command with arguments
  Kwrd = Left$(cmd, k - 1)  'keyword
  While Mid$(cmd, k, 1) = " "
   k = k + 1
  Wend
  ArgS = Mid$(cmd, k)       'arguments
Else
  'command without arguments
  Kwrd = cmd
  ArgS = ""
End If

'command Ok
sintax_ctrl = 0

Select Case UCase$(Kwrd)

  Case "USER":  'USER <username>
  sintax_ctrl = args_ctrl(ArgS, "username", Argument())

  Case "PASS": 'PASS <password>
  sintax_ctrl = args_ctrl(ArgS, "password", Argument())

  Case "ACCT":
  sintax_ctrl = 4 'command not implemented

  Case "CWD", "XCWD": 'CWD <pathname>
  sintax_ctrl = args_ctrl(ArgS, "pathname", Argument())

  Case "CDUP", "XCUP":  'CDUP
  '------------------

  Case "SMNT":
  sintax_ctrl = 4 'command not implemented

  Case "QUIT": 'QUIT
  '-----------------

  Case "REIN": 'REIN
  sintax_ctrl = 4 'command not implemented

  Case "PORT": 'PORT <host-port>
  sintax_ctrl = args_ctrl(ArgS, "host-port", Argument())

  Case "PASV":
  sintax_ctrl = 4 'command not implemented

  Case "TYPE": 'TYPE <type-code>
  sintax_ctrl = args_ctrl(ArgS, "type-code", Argument())

  Case "STRU": 'STRU <structure-code>
  sintax_ctrl = args_ctrl(ArgS, "structure-code", Argument())

  Case "MODE": 'MODE <mode-code>
  sintax_ctrl = args_ctrl(ArgS, "mode-code", Argument())

  Case "RETR": 'RETR <pathname>
  sintax_ctrl = args_ctrl(ArgS, "pathname", Argument())

  Case "STOR": 'STOR <pathname>
  sintax_ctrl = args_ctrl(ArgS, "pathname", Argument())

  Case "STOU":
  sintax_ctrl = 4 'command not implemented

  Case "APPE":
  sintax_ctrl = 4 'command not implemented

  Case "ALLO":
  sintax_ctrl = 1 'command not implemented, superfluous at this side

  Case "REST":
  sintax_ctrl = 4 'command not implemented

  Case "RNFR":  'RNFR <pathname>
  sintax_ctrl = args_ctrl(ArgS, "pathname", Argument())

  Case "RNTO":  'RNTO <pathname>
  sintax_ctrl = args_ctrl(ArgS, "pathname", Argument())

  Case "ABOR":
  sintax_ctrl = 4 'command not implemented

  Case "DELE":  'DELE <pathname>
  sintax_ctrl = args_ctrl(ArgS, "pathname", Argument())

  Case "RMD", "XRMD": 'RMD <pathname>
  sintax_ctrl = args_ctrl(ArgS, "pathname", Argument())

  Case "MKD", "XMKD": 'MKD <pathname>
  sintax_ctrl = args_ctrl(ArgS, "pathname", Argument())

  Case "PWD", "XPWD": 'PWD
  '----------------

  Case "LIST": 'LIST <pathname>
  sintax_ctrl = args_ctrl(ArgS, "pathname", Argument())

  Case "NLST": 'NLST <pathname>
  sintax_ctrl = args_ctrl(ArgS, "pathname", Argument())

  Case "SITE":
  sintax_ctrl = 4 'command not implemented

  Case "SYST":  'SYST
  '------------------

  Case "STAT":  'STAT <pathname>
  sintax_ctrl = args_ctrl(ArgS, "pathname", Argument())

  Case "HELP":  'HELP <string>
  sintax_ctrl = args_ctrl(ArgS, "string", Argument())

  Case "NOOP": 'NOOP
  '-----------------

  Case Else
  sintax_ctrl = 2 'sintax error, command unrecognized

End Select

End Function